home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / format.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  11KB  |  523 lines
  1. /* ******************************************************************** */
  2. /* format.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Formatted IO                               */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, June 1990
  10.  * $Id: format.c,v 1.6 1992/04/27 21:56:08 pab Exp $
  11.  *
  12.  * $Log: format.c,v $
  13.  * Revision 1.6  1992/04/27  21:56:08  pab
  14.  * corrected format
  15.  * ,
  16.  *
  17.  * Revision 1.5  1992/01/09  22:28:50  pab
  18.  * Fixed for low tag ints
  19.  *
  20.  * Revision 1.4  1992/01/05  22:48:03  pab
  21.  * Minor bug fixes, plus BSD version
  22.  *
  23.  * Revision 1.3  1991/12/22  15:14:04  pab
  24.  * Xmas revision
  25.  *
  26.  * Revision 1.2  1991/09/11  12:07:11  pab
  27.  * 11/9/91 First Alpha release of modified system
  28.  *
  29.  * Revision 1.1  1991/08/12  16:49:35  pab
  30.  * Initial revision
  31.  *
  32.  * Revision 1.9  1991/02/13  18:19:31  kjp
  33.  * Altered format NOT to call allocate string.
  34.  *
  35.  * Revision 1.8  1990/12/18  14:32:09  jpff
  36.  * Binary Format fix
  37.  *
  38.  * Revision 1.7  90/12/18  14:27:28  jpff
  39.  * typo
  40.  * 
  41.  * Revision 1.6  90/12/18  14:25:34  jpff
  42.  * Improved e f and g formats, implemented b formay
  43.  * 
  44.  * Revision 1.5  90/12/18  14:06:47  jpff
  45.  * More on format
  46.  * 
  47.  * Revision 1.4  90/12/18  13:17:28  jpff
  48.  * Extra formats
  49.  * 
  50.  * Revision 1.3  90/12/18  12:27:29  jpff
  51.  * Added formats, and case labels for unimplemented stuff
  52.  * 
  53.  * Revision 1.2  90/11/23  16:36:05  is
  54.  * Added Id and Log fields
  55.  * Added ~u (for uniq) format specifier, which prints out nil or the hex
  56.  * address of the object
  57.  * 
  58.  */
  59.  
  60.  
  61. #include <string.h>
  62. #include <stdio.h>
  63. #include "funcalls.h"
  64. #include "defs.h"
  65. #include "structs.h"
  66. #include "error.h"
  67. #include "global.h"
  68.  
  69. #include "modboot.h"
  70. #include "symboot.h"
  71.  
  72. #include "ngenerics.h"
  73.  
  74. #include "sio.h" 
  75.  
  76. /*
  77.  
  78.  * O..
  79.  
  80.  */
  81.  
  82. LispObject format_to_string(LispObject *stacktop,
  83.                             LispObject format,LispObject list)
  84. {
  85.   char *walker = stringof(format);
  86.   int index;
  87.  
  88.   /* Hack using socket writer... */
  89.  
  90.   BUFFER_PTR() = 0;
  91.  
  92.   while (TRUE) {
  93.  
  94.     index = 0;
  95.  
  96.     while (*walker != '~' && *walker != '\0') {
  97.  
  98.       *(BUFFER()) = *walker;
  99.  
  100.       ++walker; ++index; ++(BUFFER_PTR());
  101.  
  102.     }
  103.  
  104.     if (*walker == '\0') {
  105.       
  106.       *(BUFFER()) = '\0';
  107.       
  108.       return((LispObject) 
  109.          allocate_string(stacktop,BUFFER_START(),strlen(BUFFER_START())));
  110.  
  111.     }
  112.  
  113.     ++walker;
  114.  
  115.     switch (*walker) {
  116.  
  117.     case '\0':
  118.       CallError(stacktop,"format: ~ at end of string",format,NONCONTINUABLE);
  119.       break;
  120.     case '~':
  121.       *(BUFFER()) = '~';
  122.       ++(BUFFER_PTR());
  123.       break;
  124.     case '%':
  125.       *(BUFFER()) = '\n';
  126.       ++(BUFFER_PTR());
  127.       break;
  128.     case 't':
  129.       *(BUFFER()) = '\t';
  130.       ++(BUFFER_PTR());
  131.       break;
  132.     case '|':
  133.       *(BUFFER()) = '\f';
  134.       ++(BUFFER_PTR());
  135.       break;
  136.     case 'a':
  137.       if (is_cons(list)) {
  138.     if (is_string(CAR(list))) {
  139.       strcpy(BUFFER(),stringof(CAR(list)));
  140.       BUFFER_PTR() += strlen(stringof(CAR(list)));
  141.     }
  142.     else {
  143.       write_object(stacktop,CAR(list));
  144.     }
  145.  
  146.     list = CDR(list);
  147.  
  148.       }
  149.       else {
  150.  
  151.     write_object(stacktop,nil);
  152.  
  153.       }
  154.       break;
  155.     default:
  156.       *(BUFFER()) = *walker;
  157.       ++(BUFFER_PTR());
  158.       break;
  159.  
  160.     }
  161.  
  162.     ++walker;
  163.   }
  164.  
  165.   return(nil);
  166. }
  167.  
  168. /* Lisp.. */
  169.  
  170. #define FORMAT_BUFFER_SIZE (512)
  171.  
  172. EUFUN_3( Fn_format, str, format, list)
  173. {
  174.   extern LispObject Gf_generic_prin(LispObject*);
  175.   extern LispObject Gf_generic_write(LispObject*);
  176.  
  177.   LispObject ostream,pstring;
  178.   char buffer[FORMAT_BUFFER_SIZE];
  179.   char *walker;
  180.   int index;
  181.  
  182.   if (!is_string(format))
  183.     CallError(stacktop,"format: not a string",format,NONCONTINUABLE);
  184.  
  185.   if (str == nil) return(format_to_string(stacktop,format,list));
  186.  
  187.   if (str == lisptrue) ostream = StdOut;
  188.   else ostream = str;
  189.  
  190.   if (!is_stream(ostream))
  191.     CallError(stacktop,"format: not a stream",ostream,NONCONTINUABLE);
  192.  
  193.   if (!is_string(format))
  194.     CallError(stacktop,"format: not a string",format,NONCONTINUABLE);
  195.  
  196.   /* Copy the string into the buffer until a tilda... */
  197.  
  198.   walker = stringof(format);
  199.  
  200.   while (TRUE) {
  201.  
  202.     index = 0;
  203.  
  204.     while (*walker != '~' && *walker != '\0') {
  205.  
  206.       if (index >= FORMAT_BUFFER_SIZE)
  207.     CallError(stacktop,
  208.           "format: out of buffer space",format,NONCONTINUABLE);
  209.  
  210.       buffer[index] = *walker;
  211.  
  212.       walker += 1; ++index;
  213.       
  214.     }
  215.  
  216.     buffer[index] = '\0';
  217.  
  218.     /* Output this string... */
  219.  
  220.     /*
  221.     STACK_TMP(ostream);
  222.     pstring = (LispObject) allocate_string(stacktop,buffer,index);
  223.     UNSTACK_TMP(ostream);
  224.     STACK_TMP(ostream);
  225.     EUCALL_2(Gf_generic_prin,pstring,ostream);
  226.     UNSTACK_TMP(ostream);
  227.     
  228.     */
  229.  
  230.     /* Cheat... */
  231.  
  232.     fprintf(ostream->STREAM.handle,"%s",buffer);
  233.  
  234.     if (*walker == '\0') {
  235.  
  236.       /* All done... */
  237.       return(nil);
  238.  
  239.     }
  240.  
  241.     /* We have a tilde modifier... */
  242.  
  243.     ++walker;
  244.  
  245.     list = ARG_2(stackbase);
  246.     format = ARG_1(stackbase);
  247.     switch (*walker) {
  248.  
  249.     case '\0': 
  250.       CallError(stacktop,"format: ~ at end of string",format,NONCONTINUABLE);
  251.       break;
  252.     case '~':
  253.       fprintf(ostream->STREAM.handle,"~");
  254.       break;
  255.     case '%':
  256.       fprintf(ostream->STREAM.handle,"\n");
  257.       break;
  258.     case 't':
  259.       fprintf(ostream->STREAM.handle,"\t");
  260.       break;
  261.     case '|':
  262.       fprintf(ostream->STREAM.handle,"\f");
  263.       break;
  264.     case 'a':
  265.       {
  266.     LispObject obj;
  267.  
  268.     if (is_cons(list)) {
  269.       obj = CAR(list);
  270.       ARG_2(stackbase) = list = CDR(list);
  271.     }
  272.     else obj = nil;
  273.  
  274.     STACK_TMP(ostream);
  275.     EUCALL_2(Gf_generic_prin,obj,ostream);
  276.     UNSTACK_TMP(ostream);
  277.  
  278.     break;
  279.       }
  280.     case 's':
  281.       {
  282.     LispObject obj;
  283.  
  284.     if (is_cons(list)) {
  285.       obj = CAR(list);
  286.       ARG_2(stackbase) = list = CDR(list);
  287.     }
  288.     else obj = nil;
  289.  
  290.     STACK_TMP(ostream);
  291.     EUCALL_2(Gf_generic_write,obj,ostream);
  292.     UNSTACK_TMP(ostream);
  293.  
  294.     break;
  295.       }
  296.     case 'u':
  297.       {
  298.     LispObject obj;
  299.  
  300.     if (is_cons(list)) {
  301.       obj = CAR(list);
  302.       ARG_2(stackbase) = list = CDR(list);
  303.     }
  304.     else obj = nil;
  305.  
  306.         fprintf(ostream->STREAM.handle,(obj==nil)?"nil":"#x%x",obj);
  307.  
  308.     break;
  309.       }
  310.     case 'c':            /* Print a character */
  311.       {
  312.     LispObject obj;
  313.  
  314.     if (is_cons(list)) {
  315.       obj = CAR(list);
  316.       ARG_2(stackbase) = list = CDR(list);
  317.     }
  318.     else obj = nil;
  319.     if (is_char(obj))
  320.       fprintf(ostream->STREAM.handle,"%c",obj->CHAR.code);
  321.     else
  322.       fprintf(ostream->STREAM.handle,"?");
  323.     break;
  324.       }
  325.     case 'd':            /* Print in decimal */
  326.       {
  327.     LispObject obj;
  328.  
  329.     if (is_cons(list)) {
  330.       obj = CAR(list);
  331.       ARG_2(stackbase) = list = CDR(list);
  332.     }
  333.     else obj = nil;
  334.     if (is_fixnum(obj))
  335.       fprintf(ostream->STREAM.handle,"%d",intval(obj));
  336.     else
  337.       fprintf(ostream->STREAM.handle,"<not-integer>");
  338.     break;
  339.       }
  340.     case 'o':            /* Print in octal */
  341.       {
  342.     LispObject obj;
  343.  
  344.     if (is_cons(list)) {
  345.       obj = CAR(list);
  346.       ARG_2(stackbase) = list = CDR(list);
  347.     }
  348.     else obj = nil;
  349.     if (is_fixnum(obj))
  350.       fprintf(ostream->STREAM.handle,"%o",intval(obj));
  351.     else
  352.       fprintf(ostream->STREAM.handle,"<not-integer>");
  353.     break;
  354.       }
  355.     case 'x':
  356.       {
  357.     LispObject obj;
  358.  
  359.     if (is_cons(list)) {
  360.       obj = CAR(list);
  361.       ARG_2(stackbase) = list = CDR(list);
  362.     }
  363.     else obj = nil;
  364.     if (is_fixnum(obj))
  365.       fprintf(ostream->STREAM.handle,"%x",intval(obj));
  366.     else
  367.       fprintf(ostream->STREAM.handle,"<not-integer>");
  368.     break;
  369.       }
  370.     case 'e':            /* Print in fpt E format */
  371.       { int n = 0, m = 0;
  372.     LispObject obj;
  373.  
  374.     if (is_cons(list)) {
  375.       obj = CAR(list);
  376.       ARG_2(stackbase) = list = CDR(list);
  377.     }
  378.     else obj = nil;
  379.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  380.     if (*walker == '.') {
  381.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  382.       if (is_float(obj))
  383.         fprintf(ostream->STREAM.handle,"%*.*E",m-n,n,obj->FLOAT.fvalue);
  384.       else
  385.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  386.       walker--;
  387.     }
  388.     else {
  389.       if (is_float(obj))
  390.         fprintf(ostream->STREAM.handle,"%E",(obj)->FLOAT.fvalue);
  391.       else
  392.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  393.       walker--;
  394.     }
  395.     break;
  396.       }
  397.     case 'f':            /* Print in fpt F format */
  398.       { int n = 0, m = 0;
  399.     LispObject obj;
  400.  
  401.     if (is_cons(list)) {
  402.       obj = CAR(list);
  403.       ARG_2(stackbase) = list = CDR(list);
  404.     }
  405.     else obj = nil;
  406.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  407.     if (*walker == '.') {
  408.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  409.       if (is_float(obj))
  410.         fprintf(ostream->STREAM.handle,"%*.*F",m-n,n,obj->FLOAT.fvalue);
  411.       else
  412.         fprintf(ostream->STREAM.handle,"<not-floating>");
  413.       walker--;
  414.     }
  415.     else {
  416.       walker--;
  417.       if (is_float(obj))
  418.         fprintf(ostream->STREAM.handle,"%F",(obj)->FLOAT.fvalue);
  419.       else
  420.         fprintf(ostream->STREAM.handle,"<not-floating>");
  421.     }
  422.     break;
  423.       }
  424.     case 'g':            /* Print in fpt G format */
  425.       { int n = 0, m = 0;
  426.     LispObject obj;
  427.  
  428.     if (is_cons(list)) {
  429.       obj = CAR(list);
  430.       ARG_2(stackbase) = list = CDR(list);
  431.     }
  432.     else obj = nil;
  433.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  434.     if (*walker == '.') {
  435.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  436.       if (is_float(obj))
  437.         fprintf(ostream->STREAM.handle,"%*.*G",m-n,n,obj->FLOAT.fvalue);
  438.       else
  439.         fprintf(ostream->STREAM.handle,"<not-floating>");
  440.       walker--;
  441.     }
  442.     else {
  443.       if (is_float(obj))
  444.         fprintf(ostream->STREAM.handle,"%G",obj->FLOAT.fvalue);
  445.       else
  446.         fprintf(ostream->STREAM.handle,"<not-floating>");
  447.       walker--;
  448.     }
  449.     break;
  450.       }
  451.     case 'b':            /* Print in binary */
  452.       {
  453.     LispObject obj;
  454.  
  455.     if (is_cons(list)) {
  456.       obj = CAR(list);
  457.       ARG_2(stackbase) = list = CDR(list);
  458.     }
  459.     else obj = nil;
  460.     if (is_fixnum(obj)) {
  461.       char bb[100];        /* WARNING: limit here */
  462.       char *p = bb;
  463.       int i = 0;
  464.       int n = intval(obj);
  465.       while (n!=0) {
  466.         *p++ = (n&1) + '0';
  467.         i++;
  468.         n >>=1;
  469.       }
  470.       for (p--; i>0; p--, i--) fprintf(ostream->STREAM.handle,"%c",*p);
  471.     }
  472.     else
  473.       fprintf(ostream->STREAM.handle,"<not-integer>");
  474.     break;
  475.       }
  476.     case 'p':            /* Prettyprint */
  477.     case '0': case '1': case '2': case '3': case '4':
  478.     case '5': case '6': case '7': case '8': case '9':
  479.     case '&':
  480.     default:
  481.       fprintf(ostream->STREAM.handle,"%c",*walker);
  482.  
  483.     }
  484.  
  485.     /* Lose character... */
  486.  
  487.     ++walker;
  488.  
  489.     /* Now, do it again... */
  490.  
  491.   }
  492.  
  493.   return(nil);
  494.  
  495. }
  496. EUFUN_CLOSE
  497.  
  498. /*
  499.  
  500.  * Module initialisation... 
  501.  
  502.  */
  503.  
  504. #define FORMATTED_IO_ENTRIES 1
  505. MODULE Module_formatted_io;
  506. LispObject Module_formatted_io_values[FORMATTED_IO_ENTRIES];
  507.  
  508. void initialise_formatted_io(LispObject *stacktop)
  509. {
  510.   BUFFER_START() = (char *)malloc(SOCKET_BUFFER_SIZE);
  511.  
  512.   open_module(stacktop,
  513.           &Module_formatted_io,
  514.           Module_formatted_io_values,
  515.           "formatted-io",
  516.           FORMATTED_IO_ENTRIES);
  517.  
  518.   (void) make_module_function(stacktop,"format",Fn_format,-3);
  519.  
  520.   close_module();
  521. }
  522.  
  523.